C TAPECERT.FOR
C THIS PROGRAM CERTIFIES MAGNETIC TAPES.
C USER SELECTABLE OPTIONS ARE: BLOCK-SIZE, RECORD-SIZE, TAPE DENSITY, 
C TEST-PATTERN, RETRY LIMIT, AND IF EXTENDED IRGS ARE ALLOWED.
C 06/04/85  S E F  JPL/MIPL
C
	IMPLICIT INTEGER (S)
C
C START DEFS
C
	INCLUDE '($MTDEF)/LIST'
C
C END OF DEFS
C
	INTEGER*4 SYS$ASSIGN,SYS$DASSGN,SYS$QIOW,SYS$TRNLOG,SYS$GETMSG
	INTEGER*4 SCHAR(2),ISTAT,KSB
	INTEGER*2 IOSB(4),NSTAT,NCHAN
	CHARACTER NPAT*1, LBLOCK*8, LNPAT*65534, LNPAT_IN*65534,
	1   IBLANK*65534, NRECRD*9
	CHARACTER TAPE*20,NDENS*4,RETRIES*3,XIRG*1
	CHARACTER KPAT(6)*1, MSGBUFF*255
C
	EXTERNAL IO$_READLBLK,   IO$_READPBLK,
	1  IO$_REWIND,     IO$_REWINDOFF,
	2  IO$_SENSEMODE,  IO$_SETCHAR,    IO$_SETMODE,
	3  IO$_SKIPRECORD
C	
	EXTERNAL IO$_WRITELBLK,  IO$_WRITEPBLK,
	1  IO$_WRITEOF,    IO$M_INHRETRY,       IO$M_INHEXTGAP,
	2  IO$M_DATACHECK
C
C
	EXTERNAL SS$_ENDOFTAPE, SS$_DATACHECK, SS$_DRVERR, 
	1  SS$_OPINCOMPL,  SS$_CTRLERR,    SS$_DATAOVERUN,
	2  SS$_ILLIOFUNC,  SS$_VOLINV,     SS$_PARITY,
	3  SS$_ENDOFFILE
C
	DATA KPAT/'FF'X,'00'X,'AA'X,'55'X,'A5'X,'E5'X/
	KBI = 5
	KBO = 6
	MAXBLKSZ = 65534
	MAXRECSZ = 65534
D	INHEXT  = %LOC(IO$M_INHEXTGAP)
D	PRINT *,'INHEXT=',INHEXT
	IOFUNC = %LOC(IO$_WRITELBLK)
D	PRINT *,'IOFUNC=',IOFUNC
	IOFUNR = %LOC(IO$_READLBLK)
D	PRINT *,'IOFUNR=',IOFUNR
	ISTAT = LIB$INIT_TIMER()
C
C IF TAPECERT IS RUN FROM A COMMAND PROCEDURE THE BLOCK_SIZE, RECORD_SIZE, 
C DENSITY, N_BLOCKS, TEST_PATTERN, ENABLE_RETRY AND ENABLE_EXTENDED_IRG MAY 
C BE PASSED TO IT THRU GLOBAL DCL SYMBOLS. THIS ALLOWS DEFAULTS TO BE SET 
C UP FOR DIFFERENT TYPES OF CERTIFICATION RUNS.
C
C GET BLOCKSIZE
C
	LBLK = MAXBLKSZ
	ISTAT=LIB$GET_SYMBOL('BLOCK_SIZE',LBLOCK,LENB)
	IF(ISTAT.EQ.1)THEN
	  DECODE(LENB,100,LBLOCK)LBLK
	  IF(LBLK.GT.MAXBLKSZ)THEN
	    TYPE *,'ERR: Max blocksize exceeded'
	    GO TO 9000
	  END IF
	END IF
D	PRINT *,'LBLK=',LBLK
	LBLK_IN = LBLK
C	DO I = 1, LBLK_IN
C	  IBLANK(I:I) = ' '
C	END DO
C
C GET RECORDSIZE
C
	LRECL = MAXRECSZ
	ISTAT=LIB$GET_SYMBOL('RECORD_SIZE',LRECORD,LENR)
	IF(ISTAT.EQ.1)THEN
	  DECODE(LENR,100,LRECORD)LRECL
	  IF(LRECL.GT.MAXRECSZ)THEN
	    TYPE *,'ERR: Max recordsize exceeded'
	    GO TO 9000
	  END IF
	END IF
D	PRINT *,'LRECL=',LRECL
C
C GET TAPE_DRIVE
C
5	CONTINUE
	ISTAT = SYS$TRNLOG('TAPE_DRIVE',LENT,TAPE,,,)
	IF(ISTAT.EQ.1)GO TO 30
	WRITE(KBO,10)
10	FORMAT('$Select TAPE_DRIVE: ')
	READ(KBI,150,END=9000,ERR=5)LENT,TAPE
	IF(LENT.EQ.0)GO TO 5
30	CONTINUE
	ISTAT = SYS$ASSIGN(TAPE,NCHAN,,)
	IF(ISTAT.NE.1)THEN
	  TYPE *,'ERR: Cannot assign tape channel'
	  GO TO 9000
	END IF
D	PRINT *,'NCHAN=',NCHAN
C
C GET DENSITY
C
	ISTAT=LIB$GET_SYMBOL('DENSITY',NDENS,LEND)
	IF(ISTAT.EQ.1)THEN
	  DECODE(LEND,100,NDENS,ERR=33)NDENSITY
	  GO TO 40
	END IF
33	CONTINUE
	WRITE(KBO,35)
35	FORMAT('$Select DENSITY [6250/1600/800]: ')
	READ(KBI,100,END=9000,ERR=33)NDENSITY
40	CONTINUE
D	PRINT *,'DENSITY=',NDENSITY
	IF(NDENSITY.EQ.6250)THEN
	  SCHAR(2) = MT$K_GCR_6250*2**MT$V_DENSITY
	ELSE IF(NDENSITY.EQ.1600)THEN
	  SCHAR(2) = MT$K_PE_1600*2**MT$V_DENSITY
	ELSE IF(NDENSITY.EQ.800)THEN
	  SCHAR(2) = MT$K_NRZI_800*2**MT$V_DENSITY
	ELSE
	  GO TO 33
	END IF
C
C GET TEST_PATTERN
C
	WRITE(KBO,48)
	ISTAT=LIB$GET_SYMBOL('TEST_PATTERN',NPAT,LENP)
	IF(ISTAT.EQ.1)THEN
	  DECODE(1,100,NPAT,ERR=45)NPATX
	  GO TO 50
	END IF
45	CONTINUE
48	FORMAT ('0',
	1'       Certification Test Patterns'/
	2'    1 - Write "11111111"B bytes "FF"X'/
	3'    2 - Write "00000000"B bytes "00"X'/
	4'    3 - Write "10101010"B bytes "AA"X'/
	5'    4 - Write "01010101"B bytes "55"X'/
	6'    5 - Write "10100101"B bytes "A5"X'/
	7'    6 - Write "11100101"B bytes "E5"X'/
	8'    7 - Cycle 1 thru 6'
	9 )
	WRITE(KBO,49)
49	FORMAT('$Select TEST_PATTERN: ')
	READ(KBI,100,END=9000,ERR=45)NPATX
100	FORMAT(I9)
50	CONTINUE
C
C GET N_RECORDS
C
	IF(NPATX.LT.1.OR.NPATX.GT.7)GO TO 45
	ISTAT=LIB$GET_SYMBOL('N_RECORDS',NRECRD,LENR)
	IF(ISTAT.EQ.1)THEN
	  GO TO 200
	END IF
60	CONTINUE
	WRITE(KBO,65)
65	FORMAT('$Select N_RECORDS to write to tape or FILL: ')
	READ(KBI,150,END=9000,ERR=60)LENR,NRECRD
150	FORMAT(Q, A)
200	CONTINUE
	IF(LENR.EQ.0)GO TO 60
	ISTAT = STR$UPCASE(NRECRD(1:LENR),NRECRD(1:LENR))
	IF(NRECRD(1:4).EQ.'FILL')GO TO 250
	DECODE(LENR,100,NRECRD,ERR=60)NRECORD
C
C CHECK RETRIES ENABLED AND GET COUNT. UP TO 999 RETRIES WILL BE MADE
C TO WRITE ON OR READ A SPOT ON THE TAPE (VMS DEFAULT=16).
C
250	CONTINUE
D	PRINT *,'NRECORD=',NRECORD
	ISTAT = LIB$GET_SYMBOL('RETRIES',RETRIES,LENWC)
	IF(ISTAT.EQ.1)THEN
	  GO TO 260
	END IF
252	CONTINUE
	WRITE(KBO,255)
255	FORMAT('$RETRIES [D,0-99] (D= VMS default): ')
	READ(KBI,150,END=9000,ERR=252)LENWC,RETRIES
	IF(LENWC.GT.2)GO TO 250
260	CONTINUE
	ISTAT = STR$UPCASE(RETRIES(1:LENWC),RETRIES(1:LENWC))
	IF(RETRIES(1:1).EQ.'D')THEN
	  NRETRY = 0
	  GO TO 270
	END IF
	DECODE(LENWC,100,RETRIES,ERR=252)NRETRY
C NOTE: IT IS NECESSARY TO INHIBIT VMS RETRIES IN ORDER TO DO IT OURSELVES
	IOFUNC = IOFUNC.OR.%LOC(IO$M_INHRETRY)  !INHIBIT VMS WRITE RETRIES 
D	PRINT *,'IOFUNC=',IOFUNC
	IOFUNR = IOFUNR.OR.%LOC(IO$M_INHRETRY)  !INHIBIT VMS READ RETRIES
D	PRINT *,'IOFUNR=',IOFUNR
C
C CHECK IF EXTENDED INTERRECORD GAP ENABLED. IF ENABLED, UP TO 16 IRGS
C WILL BE WRITTEN TO SPACE PAST A BAD SPOT ON THE TAPE (VMS DEFAULT=YES)
C
270	CONTINUE
D	PRINT *,'RETRIES, NRETRY=',RETRIES(1:LENWC),NRETRY
	ISTAT = LIB$GET_SYMBOL('ENABLE_EXTENDED_IRG',XIRG,LENIRG)
	IF(ISTAT.EQ.1)THEN
	  GO TO 285
	END IF
275	CONTINUE
	WRITE(KBO,280)
280	FORMAT('$ENABLE_EXTENDED_IRG? [Y/N]: ')
	READ(KBI,150,END=9000,ERR=275)LENIRG,XIRG
285	CONTINUE
	IF(LENIRG.NE.1)GO TO 270
	ISTAT = STR$UPCASE(XIRG(1:1),XIRG(1:1))
	IF(XIRG(1:1).EQ.'Y')GO TO 290
	IF(XIRG(1:1).EQ.'N')THEN
	  IOFUNC = IOFUNC.OR.%LOC(IO$M_INHEXTGAP)	!INHIBIT
D	  PRINT *,'IOFUNC=',IOFUNC			!EXTENDED IRG
	  GO TO 290
	END IF
	GO TO 275
C
C BUILD TEST_PATTERN RECORD
C
290	CONTINUE
D	PRINT *,'XIRG=',XIRG(1:1)
	IF(NPATX.EQ.7)THEN	!TEST FOR "CYCLE 1-6" PATTERN
	  KPATX = 1
	  DO I=1, LBLK
	    IF(KPATX.GT.6) KPATX = 1
	    LNPAT(I:I) = KPAT(KPATX)
	    KPATX = KPATX + 1
	  END DO
	ELSE
	  DO I=1, LBLK
	    LNPAT(I:I) = KPAT(NPATX)
	  END DO
	END IF
C
C SET DENSITY AND REWIND TAPE
C	
	ISTAT = LIB$INIT_TIMER()
	ISTAT = SYS$QIOW(,%VAL(NCHAN),IO$_SETMODE,IOSB(1),,,SCHAR,,,,,)
	ISTAT = SYS$QIOW(,%VAL(NCHAN),IO$_REWIND,IOSB(1),,,,,,,,)
D	PRINT *,'NCHAN=',NCHAN
D	PRINT *,'NRECORD=',NRECORD
D	PRINT *,'LRECL=',LRECL
D	PRINT *,'LBLK=',LBLK
D	PRINT *,'IOFUNC=',IOFUNC
D	PRINT *,'IOFUNR=',IOFUNR
	TYPE *,' '
	TYPE *,'WRITING Test Patterns:'
	TYPE *,'  Tape drive    =  ',TAPE
	TYPE *,'  Retries       =  ',RETRIES(1:LENWC)
	TYPE *,'  Extended IRG  =  ',XIRG(1:1)
	TYPE *,'  Density  =',NDENSITY
	TYPE *,'  Pattern  =',NPATX
	TYPE *,' '
	INCORCT = 0
	INCREAD = 0
	NREC = 0
	NTRY = 0
C
C LOOP TO WRITE TEST PATTERN RECORDS
C
500	CONTINUE
	  ISTAT = SYS$QIOW(,%VAL(NCHAN),
	1   %VAL(IOFUNC),
	2   IOSB(1),,,
	3   %REF(LNPAT),%VAL(LBLK),,,,)
	  IF(.NOT.ISTAT)THEN
D	    TYPE *,'QIOW ISTAT =',ISTAT,' IOSB(1) =',IOSB(1)
	    JSTAT = SYS$GETMSG(%VAL(ISTAT),LENM,MSGBUFF,%VAL(15),)
	    TYPE *,MSGBUFF(1:LENM)
	  END IF
	  NSTAT = IOSB(1)
	  IF(NSTAT.EQ.%LOC(SS$_ENDOFTAPE))GO TO 1000	!CHECK FOR EOT
C
C CHECK FOR RETRY CONDITION, IF TRUE THEN SKIP BACK AND REWRITE RECORD
C
	  IF(NSTAT.EQ.%LOC(SS$_PARITY) .OR.
	1    NSTAT.EQ.%LOC(SS$_DATACHECK)) THEN
	     NTRY = NTRY + 1
!D	     LSTAT = SYS$GETMSG(%VAL(NSTAT),LENM,MSGBUFF,%VAL(15),)
!D	     TYPE *,MSGBUFF(1:LENM)
	     IF(NTRY.LE.NRETRY)THEN
	       WRITE(KBO,555)NREC+1,NTRY
555	       FORMAT(' Attempting to write Blk#',I6,'  Retry count =',I3)
	       KSTAT = SYS$QIOW(,%VAL(NCHAN),IO$_SKIPRECORD,
	1        IOSB(1),,,%VAL(-1),,,,,)
               IF(.NOT.KSTAT) THEN
	         LSTAT = SYS$GETMSG(%VAL(KSTAT),LENM,MSGBUFF,%VAL(15),)
	         TYPE *,MSGBUFF(1:LENM)
	       END IF
	       GO TO 500
	     END IF
	  END IF
	  NTRY = 0
	  NREC = NREC + 1
	  IF(.NOT.NSTAT)THEN
D	    TYPE *,'QIOW NSTAT =',NSTAT
	    MSTAT = SYS$GETMSG(%VAL(NSTAT),LENM,MSGBUFF,%VAL(15),)
	    TYPE *,MSGBUFF(1:LENM)
	    IF(NSTAT.EQ.%LOC(SS$_PARITY))    INCORCT = INCORCT + 1
	    IF(NSTAT.EQ.%LOC(SS$_DATACHECK)) INCORCT = INCORCT + 1
	    IF(NSTAT.EQ.%LOC(SS$_DRVERR))    INCORCT = INCORCT + 1
	    IF(NSTAT.EQ.%LOC(SS$_OPINCOMPL)) INCORCT = INCORCT + 1
	    IF(NSTAT.EQ.%LOC(SS$_DATAOVERUN))INCORCT = INCORCT + 1
	    IF(NSTAT.EQ.%LOC(SS$_ILLIOFUNC)) INCORCT = INCORCT + 1
	    XMB=NREC*LBLK*.000001
	    WRITE(KBO,700)NREC,LBLK,NPATX,XMB,NDENSITY,INCORCT
	  END IF
	  IF(MOD(NREC,1000).EQ.0)THEN
	    XMB=NREC*LBLK*.000001
	    WRITE(KBO,700)NREC,LBLK,NPATX,XMB,NDENSITY,INCORCT
700	    FORMAT(' ',I7,' (',I5,' byte) Pattern',I2,
	1   ' Blks,',F8.1,' MB,',I5,' BPI, Total errs=',I6)
	  END IF
	  IF(NRECRD(1:4).EQ.'FILL')GO TO 500
	  IF(NREC.GE.NRECORD)GO TO 1000
	GO TO 500
C
C WRITE EOT
C
1000	CONTINUE
	ISTAT = SYS$QIOW(,%VAL(NCHAN),IO$_WRITEOF,IOSB(1),,,,,,,,)
	ISTAT = SYS$QIOW(,%VAL(NCHAN),IO$_WRITEOF,IOSB(1),,,,,,,,)
	ISTAT = SYS$DASSGN(NCHAN)
	XMB=NREC*LBLK*.000001
	WRITE(KBO,700)NREC,LBLK,NPATX,XMB,NDENSITY,INCORCT
	ISTAT = SYS$ASSIGN(TAPE,NCHAN,,)
	ISTAT = SYS$QIOW(,%VAL(NCHAN),IO$_SETMODE,IOSB(1),,,SCHAR,,,,,)
	ISTAT = SYS$QIOW(,%VAL(NCHAN),IO$_REWIND,IOSB(1),,,,,,,,)
	NREC = 0
	NTRY = 0
C
C RE_READ TAPE
C
	TYPE *,' '
	TYPE *,'VERIFYING Test Patterns:'
	TYPE *,' '
5000	CONTINUE
C	  LNPAT_IN = IBLANK(1:LBLK_IN)
	  IOSB(2) = 1	!SET RETURN LENGTH TO A VALID VALUE
	  ISTAT = SYS$QIOW(,%VAL(NCHAN),
	1   %VAL(IOFUNR),
	2   IOSB(1),,,
	3   %REF(LNPAT_IN),%VAL(LBLK_IN),,,,)
	  IF(.NOT.ISTAT)THEN
D	    TYPE *,'QIOW ISTAT =',ISTAT,' IOSB(1) =',IOSB(1)
	    JSTAT = SYS$GETMSG(%VAL(ISTAT),LENM,MSGBUFF,%VAL(15),)
	    TYPE *,MSGBUFF(1:LENM)
	  END IF
	  NSTAT = IOSB(1)
	  IF(NSTAT.EQ.%LOC(SS$_ENDOFFILE))GO TO 9000	!CHECK FOR EOF
	  IF(NSTAT.EQ.%LOC(SS$_ENDOFTAPE))GO TO 9000	!CHECK FOR EOT
C
C CHECK FOR RETRIES
C
	  IF(NSTAT.EQ.%LOC(SS$_PARITY) .OR.
	1    NSTAT.EQ.%LOC(SS$_DATACHECK)) THEN
	     NTRY = NTRY + 1
!D	     LSTAT = SYS$GETMSG(%VAL(NSTAT),LENM,MSGBUFF,%VAL(15),)
!D	     TYPE *,MSGBUFF(1:LENM)
	     IF(NTRY.LE.NRETRY)THEN
	       WRITE(KBO,5550)NREC+1,NTRY
5550	       FORMAT(' Attempting to read Blk#',I6'  Retry count =',I3)
	       KSTAT = SYS$QIOW(,%VAL(NCHAN),IO$_SKIPRECORD,
	1        IOSB(1),,,%VAL(-1),,,,,)
               IF(.NOT.KSTAT) THEN
	         LSTAT = SYS$GETMSG(%VAL(KSTAT),LENM,MSGBUFF,%VAL(15),)
	         TYPE *,MSGBUFF(1:LENM)
	       END IF
	       GO TO 5000
	     END IF
	  END IF
	  NTRY = 0
	  NREC = NREC + 1
	  IF(.NOT.NSTAT)THEN
D	    TYPE *,'QIOW NSTAT =',NSTAT
	    MSTAT = SYS$GETMSG(%VAL(NSTAT),LENM,MSGBUFF,%VAL(15),)
	    TYPE *,MSGBUFF(1:LENM)
	    IF(NSTAT.EQ.%LOC(SS$_DRVERR))    INCORCT = INCORCT + 1
	    IF(NSTAT.EQ.%LOC(SS$_OPINCOMPL)) INCORCT = INCORCT + 1
	    IF(NSTAT.EQ.%LOC(SS$_DATACHECK)) INCORCT = INCORCT + 1
	    IF(NSTAT.EQ.%LOC(SS$_DATAOVERUN))INCORCT = INCORCT + 1
	    IF(NSTAT.EQ.%LOC(SS$_ILLIOFUNC)) INCORCT = INCORCT + 1
	    IF(NSTAT.EQ.%LOC(SS$_PARITY))    INCORCT = INCORCT + 1
	    XMB=NREC*LBLK*.000001
	    WRITE(KBO,7000)NREC,LBLK,NPATX,XMB,NDENSITY,INCORCT
	  END IF
C CHECK FOR A DIFFERENCE
	  IF(LNPAT(1:LBLK).NE.LNPAT_IN(1:IOSB(2)))THEN
	    INCREAD = INCREAD + 1
	    WRITE(KBO,6666)NREC,INCREAD
6666	    FORMAT(' Certification read error on Blk#',I6,
	1   '  Read errs=',I6)
	  END IF
	  IF(MOD(NREC,1000).EQ.0)THEN
	    XMB=NREC*LBLK*.000001
	    WRITE(KBO,7000)NREC,LBLK,NPATX,XMB,NDENSITY,INCORCT
7000	    FORMAT(' ',I7,' (',I5,' byte) Pattern',I2,
	1   ' Blks,',F8.1,' MB,',I5,' BPI, Total errs=',I6)
	  END IF
	GO TO 5000
C
9000	CONTINUE
	TYPE *,' '
	TYPE *,'END_OF_TAPE Totals:'
	WRITE(KBO,700)NREC,LBLK,NPATX,XMB,NDENSITY,INCORCT
	TYPE *,'Certification read errors  =',INCREAD
	TYPE *,' '
	TYPE *,'  Tape drive    =  ',TAPE
	TYPE *,'  Retries       =  ',RETRIES(1:LENWC)
	TYPE *,'  Extended IRG  =  ',XIRG(1:1)
	TYPE *,'  Density  =',NDENSITY
	TYPE *,'  Pattern  =',NPATX
	ISTAT = LIB$SHOW_TIMER()
9999	CONTINUE
	ISTAT = SYS$QIOW(,%VAL(NCHAN),IO$_REWIND,IOSB(1),,,,,,,,)
	ISTAT = SYS$DASSGN(NCHAN)
	CALL EXIT
	END
